Pascal Super Library/Pascal Super Library (CW International)(1997).bin/LIBRARY/PBLIB1/PROGS/TLISTER.PAS

Pascal/Delphi Source File | 1994-05-03 | 7KB | 246 lines

(*PAGE*)
PROGRAM TLISTER;

Uses DOS, CRT, PbCRT, PbMISC, PbDATA, PbOBJS, PbHIGH, PbPARMS;

{
Description :  Pascal Source file printer

Author      : Howard Richoux
Date        : 11/89
Last revised: lots over a long time
              2/18/94   3.02 NEW LIBRARIES
Application : IBM PC and compatibles, done in Turbo Pascal 7.0
Status      : Placed in the Public Domain by HNR Software 1/29/94
Published in: none
}



var S            : string;
    outfile      : string[40];
    fname        : string[40];

var L : OUT_object_1;

    compressed        : boolean;
    InterfaceOnlyFlag : boolean;


{*****************************************************************}


Function Command(line : string) : boolean;
var i : integer;
    begin
    Command := false;
    if (copy(line,1,6) = '(*PAGE') or (copy(line,1,5) = '{PAGE') then
         begin
         Command := true;
         i := length(line);
         if i > 9 then L.pagelabel1 := copy(line,7,i-9);
         L.donewithpage;
         end;
    end;



Procedure ListFile(fname : string);
var line,cmd : string;
    done : boolean;
    tx   : TFILE_object;
    begin
    if not FileExists(fname) then
        begin
        writeln('');
        writeln('Listfile - file not found [',fname,']');
        exit;
        end;
    writeln('Listing file ',fname);

    L.ResetCounts;
    pCurrFName := UpCaseStr(fname);
    L.pagelabel1 := Packtimestr(FileDate(pCurrFname,''));

    tx.init(pCurrFName,false);
    done := false;
    while tx.fetchnext(line) and not done do
        begin
        if not Command(line) then
             begin
             L.out(line);
             if InterfaceOnlyFlag then
                  begin
                  cmd := UpCaseStr(leftstr(line,14));
                  trim(cmd);
                  if cmd = 'IMPLEMENTATION' then done := true;
                  end;
             end;
        if keypressed then done := true;
        end;
    tx.done;
    L.donewithpage;
    end;


Function IsThisUnitFile(fname : string) : boolean;
         {check the first 100 lines for the word 'INTERFACE'}
var line : string;
    count, printed : integer;
    done : boolean;
    found : boolean;
    tx   : TFILE_object;
    begin
    found := false;
    done := false;
    count := 200; printed := 0;
    pCurrFName := UpCaseStr(fname);
    tx.init(pCurrFName,false);
    while tx.fetchnext(line) and not done do
        begin
        trim(line);
        if leftstr(UpCaseStr(line),9) = 'INTERFACE' then found := true;
        if keypressed then done := true;
        inc(printed);
        if printed > count then done := true;
        if found then done := true;
        end;
    tx.done;
    if found and pDEBUG then
         writeln('IsThisUnitFile? ',leftstr(fname,24),'  YES')
    else if pDEBUG then
         writeln('IsThisUnitFile? ',leftstr(fname,24),'  NO');
    IsThisUnitFile := found;
    end;


Function LocateFile(var fn : string) : boolean;
var i :integer;
    found : boolean;
    begin
    found := true;
    if      FileExists(fn + '.pas') then fn := fn + '.pas'
    else if FileExists(fn + '.txt') then fn := fn + '.txt'
    else if FileExists(fn + '.doc') then fn := fn + '.doc'
    else found := false;
    if InterfaceOnlyFlag and (not IsThisUnitFile(fn)) then
        found := false;
    LocateFile := found;
    end;


Function ExcludeFile(var fn : string) : boolean;
var exclude : boolean;
    exten   : string[4];
    begin
    exten := UpCaseStr(rightstr(fn,4));
    if      exten = '.OBJ' then exclude := true
    else if exten = '.EXE' then exclude := true
    else if exten = '.COM' then exclude := true
    else if exten = '.MAP' then exclude := true
    else if exten = '.LST' then exclude := true
    else if exten = '.ARC' then exclude := true
    else if exten = '.ZIP' then exclude := true
    else if exten = '.BAK' then exclude := true
    else if exten = '.TPU' then exclude := true
    else exclude := false;
    if InterfaceOnlyFlag and (not IsThisUnitFile(fn)) then
        exclude := true;
    ExcludeFile := exclude;
    end;




Procedure ListFiles(fn : string);
var SR :searchrec;
    i  : integer;
    fname : string[80];
    fnarray : STRA_object;
    begin
    fname := fn;
    i := Pos('.',fname);
    if i = 0 then
         begin
         if LocateFile(fname) then ListFile(fname);
         end
    else begin
         i := Pos('*',fname);
         if i = 0 then Listfile(fname)
         else begin
              fnarray.init(100);
              GetfilesSTRA(fname,fnarray,fNoSort);
              if fnarray.count > 0 then
                   begin
                   fnarray.sort;
                   for i := 1 to fnarray.count do
                        begin
                        s := fnarray.fetchN(i);
                        if not ExcludeFile(s) then ListFile(s);
                        end;
                   end;
              fnarray.done;
              end;
         end;
    end;


Procedure Init;
var yy,mm,dd : word;
    fname,temp,hdr : string;
    i : integer;
    begin

    addparm(1,'OUT','');
    addparm(1,'APPEND','NO');
    addparm(1,'INTERFACE','NO');
    addparm(1,'COMPRESSED','NO');

    StandardpVarsInit;     { PARMunit standard variables }

    InterfaceOnlyFlag := CheckOK('INTERFACE');
    compressed        := CheckOK('COMPRESSED');


    Outfile         := UpCaseSTr(GetParmStr('OUT'));
    if outfile <> '' then
         begin
         if CheckOK('APPEND') then
              writeln('appending to: ',outfile)
         else writeln('listing to: ',outfile);

         L.LISTinit(outfile,OUT_typAPPEND);
         if compressed then L.SetCompressed;
         hdr := '@LABEL1     |@FILE|Page @PAGE';
         if InterfaceOnlyFlag then
              hdr := '@LABEL1 |@FILE|(INTERFACE ONLY)  Page @PAGE';
         L.SetHeaders(hdr,' ','',
                      '||@PROGID',' ');
         L.LISTOpen;
         end;
    end;


(*  Main program *)
    BEGIN
    pProgID := 'TLISTER 3.02';
    Init;

    fname := 'x';
    if ParamCount > 0 then
         begin
         fname := UpCaseStr(paramstr(1));
         if      fname = 'HELP'   then ShowDocFile
         else if fname = 'STATUS' then ListParms(0)
         else begin
              ListFiles(fname);
              L.done;
              writeln('');
              writeln('LISTER done');
              end;
         end
    else ShowDocFile;
    end.